module Language.XMLSchema.AnalysisHUnit where

import Language.XMLSchema.Analysis
import HUnit
import Text.XML.HaXml.Xml2Haskell (XmlContent(..))
import Text.XML.HaXml.Types

import Data.Relation.SetOfPairs
import Language.XMLSchema.XMLSchemaLib
import Text.XML.HaXml.Parse
import Data.Set as Set
import Data.Map as Map

--

main
  = runTestTT . TestList $ testList

labeledTest l t
  = TestLabel l (TestCase t)

testList = [ 
   labeledTest "testEmptySchema" $ do
     let s = parseSchema "<xs:schema/>"
     let g = successorGraph Set.empty emptyNameSpaceEnv s
     assertEqual "no elements" Set.empty $ collectElementNames s
     assertEqual "graph ok" emptyRel g
 , labeledTest "testSingleElement" $ do
     let d = "<xs:schema>"
          ++ "<xs:element name=\"Facilities\">"
          ++ "</xs:element>"
          ++ "</xs:schema>"
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv s
     let e = Set.fromList ["Facilities"]
     assertEqual "elements ok" e $ collectElementNames s
     assertEqual "graph ok" emptyRel g
 , labeledTest "testSingleElementWithType" $ do
     let s = "<xs:schema>"
          ++ "<xs:element name=\"Foo\" type=\"Bar\">"
          ++ "</xs:element>"
          ++ "</xs:schema>"
     let g = successorGraph Set.empty emptyNameSpaceEnv $ parseSchema s
     let e = mkRel [ (mkGlobalXsdNode Nothing "Foo" ElementKind,
                      mkGlobalXsdNode Nothing "Bar" TypeKind) ]
     assertEqual "graph ok" e g
 , labeledTest "testComplexTypeInsideElement" $ do
     let s = "<xs:schema>"
          ++ "<xs:element name=\"Foo\">"
          ++ "<xs:complexType name=\"Bar\">"
          ++ "</xs:complexType>"
          ++ "</xs:element>"
          ++ "</xs:schema>"
     let g = successorGraph Set.empty emptyNameSpaceEnv $ parseSchema s
     let foo = mkGlobalXsdNode Nothing "Foo" ElementKind
     let bar = mkXsdNode (Just foo) Nothing "Bar" TypeKind
     let e = mkRel [(foo,bar)]
     assertEqual "graph ok" e g
 , labeledTest "testNestedElementNoTypes" $ do
     let d = "<xs:schema>"
          ++ "<xs:element name=\"Foo\">"
          ++ "<xs:complexType>"
          ++ "<xs:sequence>"
          ++ "<xs:element name=\"Bar\">"
          ++ "</xs:element>"
          ++ "</xs:sequence>"
          ++ "</xs:complexType>"
          ++ "</xs:element>"
          ++ "</xs:schema>"
     let s = parseSchema d
     --putStrLn (show s)
     let ens = collectElementNames s
     assertEqual "elems ok" (Set.fromList ["Foo","Bar"]) ens
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" ElementKind
     let bar = mkXsdNode (Just foo) Nothing "Bar" ElementKind
     let e = mkRel [(foo,bar)]
     assertEqual "graph ok" e g
 , labeledTest "testGlobalTypeRecursive" $ do
     let d = "<xs:schema>"
          ++ "<xs:complexType name=\"Foo\">"
          ++ "<xs:sequence>"
          ++ "<xs:element name=\"bar\" type=\"Foo\"/>"
          ++ "</xs:sequence>"
          ++ "</xs:complexType>"
          ++ "</xs:schema>"
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" TypeKind
     let bar = mkXsdNode (Just foo) Nothing "bar" ElementKind
     let e = mkRel [(foo,bar),(bar,foo)]
     assertEqual "graph ok" e g
 , labeledTest "testGlobalTypesMutuallyRecursive" $ do
     let d = "<xs:schema>"
          ++ "<xs:complexType name=\"Foo\">"
          ++ "<xs:sequence>"
          ++ "<xs:element name=\"barElem\" type=\"Bar\"/>"
          ++ "</xs:sequence>"
          ++ "</xs:complexType>"
          ++ "<xs:complexType name=\"Bar\">"
          ++ "<xs:sequence>"
          ++ "<xs:element name=\"fooElem\" type=\"Foo\"/>"
          ++ "</xs:sequence>"
          ++ "</xs:complexType>"
          ++ "</xs:schema>"
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" TypeKind
     let barElem = mkXsdNode (Just foo) Nothing "barElem" ElementKind
     let bar = mkGlobalXsdNode Nothing "Bar" TypeKind
     let fooElem = mkXsdNode (Just bar) Nothing "fooElem" ElementKind
     let e = mkRel [(foo,barElem),(barElem,bar),(bar,fooElem),(fooElem,foo)]
     assertEqual "graph ok" e g
 , labeledTest "testGlobalElementAndType" $ do
     let d = "<xs:schema>"
          ++ "<xs:element name=\"Foo\" type=\"Bar\"/>"
          ++ "<xs:complexType name=\"Bar\">"
          ++ "<xs:sequence>"
          ++ "</xs:sequence>"
          ++ "</xs:complexType>"
          ++ "</xs:schema>"
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" ElementKind
     let bar = mkGlobalXsdNode Nothing "Bar" TypeKind
     let e = mkRel [(foo,bar)]
     assertEqual "graph ok" e g
 , labeledTest "testSimpleTypeList" $ do
     let d = "<xs:schema>"
          ++ " <xs:simpleType name=\"Foo\">"
          ++ "  <xs:restriction base=\"xs:decimal\"/>"
          ++ " </xs:simpleType>"
          ++ " <xs:simpleType name = \"List\">"
          ++ "  <xs:list itemType=\"Foo\"/>"
          ++ " </xs:simpleType>"
          ++ "</xs:schema>"
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" TypeKind
     let dec = mkGlobalXsdNode Nothing "xs:decimal" TypeKind
     let lst = mkGlobalXsdNode Nothing "List" TypeKind
     let e = mkRel [(foo,dec),(lst,foo)]
     assertEqual "graph ok" e g
 , labeledTest "testUnion" $ do
     let d = "<xs:schema>"
          ++ " <xs:simpleType name = \"Union\">"
          ++ "  <xs:union memberTypes=\"foo xs:decimal\"/>"
          ++ " </xs:simpleType>"
          ++ "</xs:schema>"
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "foo" TypeKind
     let dec = mkGlobalXsdNode Nothing "xs:decimal" TypeKind
     let unn = mkGlobalXsdNode Nothing "Union" TypeKind
     let e = mkRel [(unn,foo),(unn,dec)]
     assertEqual "graph ok" e g
 , labeledTest "testAttributeInGroup" $ do
     let d = "<xs:schema>"
          ++ " <xs:attributeGroup name=\"Foo\">"
          ++ "  <xs:attribute name=\"Bar\" type=\"BarType\"/>"
          ++ " </xs:attributeGroup>"
          ++ "</xs:schema>"
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" AttributeGroupKind
     let bar = mkXsdNode (Just foo) Nothing "Bar" AttributeKind
     let bartype = mkGlobalXsdNode Nothing "BarType" TypeKind
     let e = mkRel [(foo,bar),(bar,bartype)]
     assertEqual "graph ok" e g
 , labeledTest "testAttributeInElement" $ do
     let d = "<xs:schema>"
          ++ " <xs:element name=\"Foo\">"
          ++ "  <xs:complexType>"
          ++ "   <xs:sequence/>"
          ++ "   <xs:attribute name=\"Bar\" type=\"BarType\"/>"
          ++ "  </xs:complexType>"
          ++ " </xs:element>"
          ++ "</xs:schema>"
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" ElementKind
     let bar = mkXsdNode (Just foo) Nothing "Bar" AttributeKind
     let bartype = mkGlobalXsdNode Nothing "BarType" TypeKind
     let e = mkRel [(foo,bar),(bar,bartype)]
     assertEqual "graph ok" e g
 , labeledTest "testAttributeReference" $ do
     let d = "<xs:schema>"
          ++ " <xs:element name=\"Foo\">"
          ++ "  <xs:complexType>"
          ++ "   <xs:sequence/>"
          ++ "   <xs:attribute ref=\"Bar\"/>"
          ++ "  </xs:complexType>"
          ++ " </xs:element>"
          ++ "</xs:schema>"
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" ElementKind
     let bar = mkGlobalXsdNode Nothing "Bar" AttributeKind
     let e = mkRel [(foo,bar)]
     assertEqual "graph ok" e g
 , labeledTest "testGroupReference" $ do
     let d = "<xs:schema>"
          ++ " <xs:complexType name=\"Foo\">"
          ++ "  <xs:complexContent>"
          ++ "   <xs:extension base=\"Bar\">"
          ++ "    <xs:group ref=\"FooModel\"/>"
          ++ "   </xs:extension>"
          ++ "  </xs:complexContent>"
          ++ " </xs:complexType>"
          ++ "</xs:schema>"          
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" TypeKind
     let bar = mkGlobalXsdNode Nothing "Bar" TypeKind
     let foomodel = mkGlobalXsdNode Nothing "FooModel" GroupKind
     let e = mkRel [(foo,bar),(foo,foomodel)]
     assertEqual "graph ok" e g
 , labeledTest "testElementReference" $ do
     let d = "<xs:schema>"
          ++ " <xs:complexType name=\"Foo\">"
          ++ "  <xs:sequence>"
          ++ "   <xs:element ref=\"Bar\"/>"
          ++ "  </xs:sequence>"
          ++ " </xs:complexType>"
          ++ "</xs:schema>"          
     let s = parseSchema d
     let g = successorGraph Set.empty emptyNameSpaceEnv $ s
     let foo = mkGlobalXsdNode Nothing "Foo" TypeKind
     let bar = mkGlobalXsdNode Nothing "Bar" ElementKind
     let e = mkRel [(foo,bar)]
     assertEqual "graph ok" e g
     
 , labeledTest "test createNameSpaceEnv" $ do
     let d = "<xs:schema xmlns=\"http://www.w3.org/2001/XMLSchema\""
          ++ "  xmlns:po=\"http://www.example.com/PO1\""
          ++ "  targetNamespace=\"http://www.example.com/PO1\""
          ++ "  elementFormDefault=\"unqualified\""
          ++ "  attributeFormDefault=\"unqualified\"/>"
     let x = parseElem d
     let e = createNameSpaceEnv x
     assertEqual "default"
        (Just "http://www.w3.org/2001/XMLSchema")
        (defaultNameSpace e)
     assertEqual "target" 
        (Just "http://www.example.com/PO1")
        (targetNameSpace e)
     assertEqual "prefix"
        (Just "http://www.example.com/PO1")
        (getNS e "po")
 , labeledTest "test createAndUseNameSpaceEnv" $ do
     let d = "<xs:schema xmlns=\"http://www.w3.org/2001/XMLSchema\""
          ++ "  xmlns:po=\"http://www.example.com/PO1\""
          ++ "  targetNamespace=\"http://www.example.com/PO1\""
          ++ "  elementFormDefault=\"unqualified\""
          ++ "  attributeFormDefault=\"unqualified\"/>"
     let x = parseElem d
     let e = createNameSpaceEnv x
     assertEqual "default"
        (Just "http://www.w3.org/2001/XMLSchema")
        (defaultNameSpace e)
     assertEqual "target" 
        (Just "http://www.example.com/PO1")
        (targetNameSpace e)
     assertEqual "prefix"
        (Just "http://www.example.com/PO1")
        (getNS e "po")
     assertEqual "target prefix"
        (Just "po")
        (targetPrefix e)
     assertEqual "inserting prefix"
        (mkGlobalXsdNode Nothing "po:foo" OtherKind)
        (mkGlobalXsdNode (Just "po") "foo" OtherKind)
     let parent = mkGlobalXsdNode Nothing "foo" OtherKind
     assertEqual "inserting prefix"
        (mkXsdNode (Just parent) Nothing "po:foo" OtherKind)
        (mkXsdNode (Just parent) (Just "po") "foo" OtherKind)
 , labeledTest "test extraction of target prefix" $ do
     let e = NameSpaceEnv {
               defaultNameSpace = Just "http://www.w3.org/2001/XMLSchema", 
               targetNameSpace = Just "http://www.ibm.com/xmlns/stdwip/web-services/WS-ServiceGroup",
               prefixMap 
                = Map.fromList [ 
                    ("wsa","http://schemas.xmlsoap.org/ws/2003/03/addressing"),
                    ("wsrp","http://www.ibm.com/xmlns/stdwip/web-services/WS-ResourceProperties"),
                    ("wssg","http://www.ibm.com/xmlns/stdwip/web-services/WS-ServiceGroup"),
                    ("xsd","http://www.w3.org/2001/XMLSchema"),
                    ("xsi","http://www.w3.org/2001/XMLSchema-instance") ]
             }
     assertEqual "target prefix"
        (Just "wssg")
        (targetPrefix e)
 ]
 
 
{-
 ]
-}

--

--

parseSchema :: String -> Xs'schema
parseSchema = parseDocument

parseDocument :: (XmlContent a) => String -> a
parseDocument str = z
  where
    (Document _ _ y) = xmlParse "fileName" str
    z = maybe (error "WRONG") id (fst (fromElem [CElem y]))
    
parseElem :: String -> Element
parseElem str = y where (Document _ _ y) = xmlParse "<interactive>" str

--